home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / Modes / HTML and CSS Modes / htmlFileUtils.tcl < prev    next >
Encoding:
Text File  |  2001-01-12  |  11.9 KB  |  364 lines
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  HTML mode - tools for editing HTML documents
  4.  # 
  5.  #  FILE: "htmlFileUtils.tcl"
  6.  #                                    created: 99-07-20 18.05.44 
  7.  #                                last update: 00-12-22 21.30.57 
  8.  #  Author: Johan Linde
  9.  #  E-mail: <alpha_www_tools@go.to>
  10.  #     www: <http://go.to/alpha_www_tools>
  11.  #  
  12.  # Version: 3.0
  13.  # 
  14.  # Copyright 1996-2001 by Johan Linde
  15.  #  
  16.  # This program is free software; you can redistribute it and/or modify
  17.  # it under the terms of the GNU General Public License as published by
  18.  # the Free Software Foundation; either version 2 of the License, or
  19.  # (at your option) any later version.
  20.  # 
  21.  # This program is distributed in the hope that it will be useful,
  22.  # but WITHOUT ANY WARRANTY; without even the implied warranty of
  23.  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  24.  # GNU General Public License for more details.
  25.  # 
  26.  # You should have received a copy of the GNU General Public License
  27.  # along with this program; if not, write to the Free Software
  28.  # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  29.  # 
  30.  # ###################################################################
  31.  ##
  32.  
  33. #===============================================================================
  34. # This file contains various file routines for handling HTML links.
  35. #===============================================================================
  36.  
  37. #===============================================================================
  38. # ◊◊◊◊ File routines ◊◊◊◊ #
  39. #===============================================================================
  40.  
  41. # Asks for a file and returns the file name including the relative path from
  42. # current window. For images the width and height are also returned.
  43. proc html::GetFile {{addtocache 1} {linkFile ""} {errormsg 0}} {
  44.     upvar pathToNewFile newFile
  45.     # get path to this window.    
  46.     if {![string length [set this [html::ThisFilePath $errormsg]]]} {return}
  47.     
  48.     # Get the file to link to.
  49.     if {$linkFile == "" && [catch {getfile "Select file to link to."} linkFile]} {
  50.         return 
  51.     }
  52.     # For html::LinkToNewFile
  53.     set newFile $linkFile
  54.     # Get URL for this file?
  55.     set link [html::BASEfromPath $linkFile]
  56.     if {[lindex $link 4] == "4"} {
  57.         alertnote "You can't link to a file in an include folder."
  58.         return
  59.     }
  60.     if {[lindex $this 4] == "4" && "[lindex $this 0][lindex $this 1]" == "[lindex $link 0][lindex $link 1]"} {
  61.         set linkTo ":HOMEPAGE:[lindex $link 2]"
  62.     } elseif {[lindex $this 0] == [lindex $link 0]} {
  63.         set linkTo [html::RelativePath "[lindex $this 1][lindex $this 2]" "[lindex $link 1][lindex $link 2]"]
  64.     } else {
  65.         set linkTo [join [lrange $link 0 2] ""]
  66.     }
  67.     set widthheight ""
  68.     if {![file isdirectory $linkFile]} {
  69.         # Check if image file.
  70.         getFileInfo $linkFile arr
  71.         if {$arr(type) == "GIFf" || [file extension $linkFile] == ".gif"} {
  72.             set widthheight [html::GIFWidthHeight $linkFile]
  73.         } elseif {$arr(type) =="JPEG" || $arr(type) == "JFIF" || [file extension $linkFile] == ".jpg"} {
  74.             set widthheight [html::JPEGWidthHeight $linkFile]
  75.         }
  76.     } else {
  77.         append linkTo /
  78.     }
  79.     # Add URL to cache
  80.     if {$addtocache} {html::AddToCache URLs $linkTo}
  81.     return [list $linkTo $widthheight]
  82. }
  83.  
  84.  
  85. # Returns the URL to the current window.
  86. proc html::ThisFilePath {errorMsg} {
  87.     
  88.     set thisFile [html::StrippedFrontWindowPath]
  89.     
  90.     # Look for BASE element.
  91.     if {![catch {search -s -f 1 -r 1 -i 1 -m 0 {<BASE[ \t\r\n]+[^>]*>} 0} res]} {
  92.         set comm 0
  93.         set commPos 0
  94.         while {![catch {search -s -f 1 -r 0 -m 0 -l [lindex $res 0] {<!--} $commPos} cres]} {
  95.             set comm 1
  96.             if {![catch {search -s -f 1 -r 0 -m 0 -l [lindex $res 0] -- {-->} [expr {[lindex $cres 1] + 1}]} cres]} {
  97.                 set comm 0
  98.                 set commPos [lindex $cres 1]
  99.             } else {
  100.                 break
  101.             }
  102.         }
  103.         if {!$comm && [regexp -nocase {HREF[ \t\n\r]*=[ \t\n\r]*("[^"]+"|'[^']+'|[^ \t\r\n>]+)} [getText [lindex $res 0] \
  104.           [lindex $res 1]] dum href]} {
  105.             set href [string trim $href "\"' \t\r\n"]
  106.             if {[catch {html::BASEpieces $href} basestr]} {
  107.                 alertnote "Window contains invalid BASE element. Ignored."
  108.             } else {
  109.                 return $basestr
  110.             }
  111.         }
  112.     }
  113.     
  114.     # Check if window is saved.
  115.     if {![file exists $thisFile]} {
  116.         switch $errorMsg {
  117.             0 {
  118.                 set etxt "You must save the window. If you save, you will then be prompted\
  119.                 for a file to link to."
  120.             }
  121.             1 {
  122.                 set etxt "You must save the window, otherwise it cannot be determined\
  123.                 where the link is pointing."
  124.             }
  125.             2 {
  126.                 set etxt "You must save the window, otherwise the link cannot be determined."
  127.             }
  128.             3 {
  129.                 set etxt "You must save the window, otherwise it cannot be determined\
  130.                 where the links are pointing."
  131.             }
  132.             4 {
  133.                 set etxt "You must save the window, otherwise it cannot be determined\
  134.                 where to upload it."
  135.             }
  136.         }
  137.         if {[lindex [dialog -w 400 -h 100 -t $etxt 10 10 390 60  \
  138.         -b Save 20 70  85 90 \
  139.         -b Cancel 110 70 175 90] 1]} {
  140.             return
  141.         }
  142.         
  143.         if {![catch {saveAs}]} {
  144.             set thisFile [html::StrippedFrontWindowPath]
  145.         } else {
  146.             return 
  147.         }
  148.     }
  149.     return [html::BASEfromPath $thisFile]
  150. }
  151.  
  152. # Returns URL to file.
  153. proc html::BASEfromPath {path} {
  154.     global HTMLmodeVars file::separator
  155.     foreach p $HTMLmodeVars(homePages) {
  156.         if {(![set i 0] && [string match [file join [lindex $p $i] *] [file join $path " "]]) || 
  157.         ([llength $p] == 5 && [set i 4] && [string match [file join [lindex $p $i] *] [file join $path " "]])} {
  158.             set path [string range $path [expr {[string length [lindex $p $i]] + 1}] end]
  159.             regsub -all ${file::separator} $path {/} path
  160.             return [list [lindex $p 1] [lindex $p 2] $path [lindex $p 0] $i [lindex $p 4]]
  161.         }
  162.     }
  163.     regsub -all ${file::separator} $path {/} path
  164.     return [list "file:///" "" [string trimleft $path ${file::separator}] "" 0]
  165. }
  166.  
  167. # Splits a BASE URL in pieces.
  168. # NOTE! That this proc returns a shorter list than the proc above, is used in
  169. # HTML::DblClick to determine if the doc contains a BASE tag.
  170. proc html::BASEpieces {href} {
  171.     if {[regexp -indices {://} $href css]} {
  172.         if {[set sl [string first / [string range $href [expr {[lindex $css 1] + 1}] end]]] >=0} {
  173.             set base [string range $href 0 [expr {[lindex $css 1] + $sl + 1}]]
  174.             set path [string range $href [expr {[lindex $css 1] + $sl + 2}] end]
  175.             set sl [string last / $path]
  176.             set epath [string range $path [expr {$sl + 1}] end]
  177.             set path [string range $path 0 $sl]
  178.         } else {
  179.             set base [string range $href 0 [lindex $css 1]]
  180.             set path ""
  181.             set epath [string range $href [expr {[lindex $css 1] + 1}] end]
  182.         }
  183.         return [list [html::URLunEscape $base] [html::URLunEscape $path] [html::URLunEscape $epath] ""]
  184.     } else {
  185.         error "Invalid BASE."
  186.     }
  187. }
  188.  
  189.  
  190. # Determines width and height of a GIF file.
  191. proc html::GIFWidthHeight {fil} {
  192.     global tcl_platform
  193.     if {[catch {open $fil r} fid]} {return}
  194.     if {$tcl_platform(platform) != "macintosh"} {
  195.         fconfigure $fid -encoding macRoman
  196.     }
  197.     if {[info tclversion] >= 8.0} {
  198.         fconfigure $fid -translation lf
  199.     }
  200.     seek $fid 6 start
  201.     set width [expr {[html::ReadOne $fid] + 256 * [text::Ascii [read $fid 1]]}]
  202.     set height [expr {[html::ReadOne $fid] + 256 * [text::Ascii [read $fid 1]]}]
  203.     close $fid
  204.     return [list $width $height]
  205. }
  206.  
  207. # Extracts width and height of a jpeg file.
  208. # Algorithm from the perl script 'wwwimagesize' by
  209. # Alex Knowles, alex@ed.ac.uk
  210. # Andrew Tong, werdna@ugcs.caltech.edu
  211. proc html::JPEGWidthHeight {fil} {
  212.     global tcl_platform
  213.     if {[catch {open $fil r} fid]} {return}
  214.     if {$tcl_platform(platform) != "macintosh"} {
  215.         fconfigure $fid -encoding macRoman
  216.     }
  217.     if {[info tclversion] >= 8.0} {
  218.         fconfigure $fid -translation lf
  219.     }
  220.     if {[text::Ascii [read $fid 1]] != 255 || [text::Ascii [read $fid 1]] != 216} {return}
  221.     set ch ""
  222.     while {![eof $fid]} {
  223.         while {[text::Ascii $ch] != 255 && ![eof $fid]} {set ch [read $fid 1]}
  224.         while {[text::Ascii $ch] == 255 && ![eof $fid]} {set ch [read $fid 1]}
  225.         if {[set asc [text::Ascii $ch]] >= 192 && $asc <= 195} {
  226.             seek $fid 3 current
  227.             set height [expr {256 * [text::Ascii [read $fid 1]] + [html::ReadOne $fid]}]
  228.             set width [expr {256 * [text::Ascii [read $fid 1]] + [html::ReadOne $fid]}]
  229.             close $fid
  230.             return [list $width $height]
  231.         } else {
  232.             set ln [expr {256 * [html::ReadOne $fid] + [html::ReadOne $fid] - 2}]
  233.             if {$ln < 0} {break}
  234.             seek $fid $ln current
  235.         }
  236.     }
  237.     close $fid
  238. }
  239.  
  240. # Reads one character from an image file.
  241. # For some mysterious reason 10 and 13 has to be swapped.
  242. proc html::ReadOne {fid} {
  243.     set c [text::Ascii [read $fid 1]]
  244.     if {[info tclversion] < 8.0} {
  245.         if {$c == 13} {
  246.             set c 10
  247.         } elseif {$c == 10} {
  248.             set c 13
  249.         }
  250.     }
  251.     return $c
  252. }
  253.  
  254.  
  255. # Returns toFile including relative path from fromFile.
  256. proc html::RelativePath {fromFile toFile} {
  257.     # Remove trailing /file from fromFile
  258.     set fromFile [string range $fromFile 0 [expr {[string last / $fromFile] - 1}]]
  259.  
  260.     set fromdir [split $fromFile /]
  261.     set todir [split $toFile /]
  262.     
  263.     # Remove the common path.
  264.     set i 0
  265.     while {[llength $fromdir] > $i && [llength $todir] > $i \
  266.     && [lindex $fromdir $i] == [lindex $todir $i]} {
  267.         incr i
  268.     }
  269.  
  270.     # Insert ../
  271.     foreach f [lrange $fromdir $i end] {
  272.         append linkTo "../"
  273.     }
  274.     # Add the path.
  275.     append linkTo [join [lrange $todir $i end] /]
  276.     
  277.     return $linkTo
  278. }
  279.  
  280. # Determine the path to the file "linkTo", as linked from "base path epath". 
  281. proc html::PathToFile {base path epath hpPath linkTo} {
  282.     global  HTMLmodeVars file::separator tcl_platform
  283.     # Expand links in include files.
  284.     regsub -nocase {^:HOMEPAGE:} $linkTo "$base$path" linkTo
  285.     # Is this a mailto or news URL or anchor?
  286.     if {[regexp {^(mailto:|news:|javascript:)} [string tolower $linkTo]]} {error $linkTo}
  287.     
  288.     # remove /file from epath
  289.     set sl [string last / $epath]
  290.     set efil [string range $epath [expr {$sl + 1}] end]
  291.     set epath [string range $epath 0 $sl]
  292.  
  293.     # anchor points to efil
  294.     if {[string index $linkTo 0] == "#"} {set linkTo $efil}
  295.     
  296.     # Remove anchor from "linkTo".
  297.     regexp {[^#]*} $linkTo linkTo
  298.     
  299.     # Remove ./ from path
  300.     if {[string range $linkTo 0 1] == "./"} {set linkTo [string range $linkTo 2 end]}
  301.     
  302.     # Relative URL beginning with / is relative to server URL.
  303.     if {[string index $linkTo 0] == "/"} {
  304.         set linkTo "$base[string range $linkTo 1 end]"
  305.     }
  306.     
  307.     # Relative URL?
  308.     if {![regexp  {://} $linkTo]} {
  309.         set fromPath [split [string trimright "${path}$epath" /] /]
  310.         set toPath [split $linkTo /]
  311.         # Back down for every ../
  312.         set i 0
  313.         foreach tp $toPath {
  314.             if {$tp == ".."} {
  315.                 incr i
  316.             } else {
  317.                 break
  318.             }
  319.         }
  320.         if {$i > [llength $fromPath] } {
  321.             error ""
  322.         } else {
  323.             set path1 [join [lrange $fromPath 0 [expr {[llength $fromPath] - $i - 1}]] /]
  324.             if {[string length $path1]} {append path1 /}
  325.             append path1 [join [lrange $toPath $i end] /]
  326.             if {[string match "$path*" $path1] && [string length $hpPath]} {
  327.                 set pathTo [string range $path1 [string length $path] end]
  328.                 regsub -all {/} $pathTo ${file::separator} pathTo
  329.                 set casePath $pathTo
  330.                 set pathTo [file join $hpPath $pathTo]
  331.                 if {![file isdirectory $pathTo]} {return [list $pathTo $casePath]}
  332.             } elseif {$base == "file:///"} {
  333.                 regsub -all {/} $path1 ${file::separator} pathTo
  334.                 return [list $pathTo $pathTo]
  335.             }
  336.             set linkTo "$base$path1"
  337.         }
  338.     }
  339.  
  340.     foreach hp [concat $HTMLmodeVars(homePages) [list [list ${file::separator} file:/// "" ""]]]  {
  341.         if {[string match "[lindex $hp 1][lindex $hp 2]*" $linkTo] ||
  342.         [string trimright "[lindex $hp 1][lindex $hp 2]" /] == $linkTo} {
  343.             set pathTo [string range $linkTo [string length "[lindex $hp 1][lindex $hp 2]"] end]
  344.             regsub -all {/} $pathTo ${file::separator} pathTo
  345.             set casePath $pathTo
  346.             if {$tcl_platform(platform) == "unix"} {
  347.                 set pathTo [file join [lindex $hp 0] $pathTo]
  348.             } else {
  349.                 set pathTo [string trimleft [file join [lindex $hp 0] $pathTo] ${file::separator}]
  350.             }
  351.             # If link to folder, add default file.
  352.             if {[file isdirectory $pathTo]} {
  353.                 set pathTo [string trimright $pathTo ${file::separator}]
  354.                 append pathTo "${file::separator}[lindex $hp 3]"
  355.                 set casePath [string trimright $casePath ${file::separator}]
  356.                 append casePath "${file::separator}[lindex $hp 3]"
  357.             }        
  358.             return [list $pathTo [string trimleft $casePath ${file::separator}]]
  359.         }
  360.     }
  361.     error $linkTo
  362. }    
  363.  
  364.